home *** CD-ROM | disk | FTP | other *** search
/ Floppyshop 2 / Floppyshop - 2.zip / Floppyshop - 2.iso / art&graf.ix / art-0039 / source / qsort.mod < prev   
Text File  |  1997-04-16  |  13KB  |  330 lines
  1. IMPLEMENTATION MODULE QSort;
  2.  
  3.  
  4. (*---------------------------------------------------------------------*)
  5. (*   A Generic Sorting Module - based on code taken from the           *)
  6. (*      book - Software Development with Modula-2 by Ford & Weiner.    *)
  7. (*                                                                     *)
  8. (*   The sort procedure will allow the user to to provide the          *)
  9. (*   compare procedure or will sort using standard data types.         *)
  10. (*   Multiple keys will NOT be allowed.                                *)
  11. (*                                                                     *)
  12. (*   The standard data types allowed for sorting will be:              *)
  13. (*     CARDINAL, INTEGER, REAL, STRING ( Null terminated ),            *)
  14. (*     LONGCARD, & LONGINT.                                            *)
  15. (*                                                                     *)
  16. (*   The objects to be sorted are considered to be an array of BYTES,  *)
  17. (*   each object being of fixed length.                                *)
  18. (*                                                                     *)
  19. (*   The array will be sorted in place.                                *)
  20. (*                                                                     *)
  21. (*  1/ 9/89 LGM : Original                                             *)
  22. (*---------------------------------------------------------------------*)
  23.  
  24. FROM SYSTEM           IMPORT BYTE, ADDRESS, ADR, TSIZE;
  25.  
  26. FROM FastMove          IMPORT Swap;
  27. (*   IMPORT Trace;  (* debugging *) *) 
  28.  
  29.  
  30.  
  31. (*----------------------------------------------------------------------*)
  32. (*      G L O B A L       C O N S T A N T S                             *)
  33. (*----------------------------------------------------------------------*)
  34.  
  35. CONST
  36.     CSelSortPartitionSize = LONGCARD(7);
  37.  
  38.  
  39. (*----------------------------------------------------------------------*)
  40. (*      G L O B A L       V A R I A B L E S                             *)
  41. (*----------------------------------------------------------------------*)
  42. VAR
  43.     ObjectSize           : LONGCARD; (* Size of ONE entry in BYTEs *)
  44.     PartitionSizeLimit   : LONGCARD; (* Limit for Selection sort   *)
  45.     ObjectArrayAddr      : ADDRESS;  (* Where array to be sorted   *)
  46.                                     (* starts in memory.          *)
  47.     InOrder                 : CompareProc;
  48.  
  49.  
  50. (*----------------------------------------------------------------------*)
  51. (*  S T A R T     O F      C O M P A R E       P R O C E D U R E S      *)
  52. (*----------------------------------------------------------------------*)
  53.  
  54. (*----------------------------------------------------------------------*)
  55. (* Compare reals: return TRUE if r1 < r2                                *)
  56. (*----------------------------------------------------------------------*)
  57. PROCEDURE RealCompare (  a1, a2 : ADDRESS ) : BOOLEAN;
  58.   TYPE rptr = POINTER TO REAL;
  59.   VAR  r1,r2 : rptr;
  60.   BEGIN
  61.     r1 := a1; r2 := a2;
  62.     RETURN ( r1^ < r2^ );
  63.   END RealCompare;
  64.  
  65.  
  66. (*----------------------------------------------------------------------*)
  67. (* Compare Cardinal: return TRUE if c1 < c2                             *)
  68. (*----------------------------------------------------------------------*)
  69. PROCEDURE CardinalCompare(  c1, c2 : ADDRESS ) : BOOLEAN;
  70.   VAR a1, a2 : POINTER TO CARDINAL;
  71.   BEGIN
  72.     a1 := c1;
  73.     a2 := c2;
  74.     RETURN ( a1^ < a2^ );
  75.   END CardinalCompare;
  76.  
  77.  
  78. (*----------------------------------------------------------------------*)
  79. (* Compare Integer : return TRUE if i1 < i2                             *)
  80. (*----------------------------------------------------------------------*)
  81. PROCEDURE IntegerCompare( i1, i2 : ADDRESS ) : BOOLEAN;
  82.   VAR a1, a2 : POINTER TO INTEGER;
  83.   BEGIN
  84.     a1 := i1;
  85.     a2 := i2;
  86.     RETURN ( a1^ < a2^ );
  87.   END IntegerCompare;
  88.  
  89.  
  90. (*----------------------------------------------------------------------*)
  91. (* Compare LongInt : return TRUE if li1 < li2                           *)
  92. (*----------------------------------------------------------------------*)
  93. PROCEDURE LongIntCompare( li1, li2 : ADDRESS ) : BOOLEAN;
  94.  VAR a1, a2 : POINTER TO LONGINT;
  95.   BEGIN
  96.     a1 := li1;
  97.     a2 := li2;
  98.     RETURN ( a1^ < a2^ );
  99.   END LongIntCompare;
  100.  
  101.  
  102. (*----------------------------------------------------------------------*)
  103. (* Compare LongCard : return TRUE if ci1 < ci2                          *)
  104. (*----------------------------------------------------------------------*)
  105. PROCEDURE LongCardCompare( lc1, lc2 : ADDRESS ) : BOOLEAN;
  106.  VAR a1, a2 : POINTER TO LONGCARD;
  107.   BEGIN
  108.     a1 := lc1;
  109.     a2 := lc2;
  110.     RETURN ( a1^ < a2^ );
  111.   END LongCardCompare;
  112.  
  113. (*----------------------------------------------------------------------*)
  114. (*     E N D      O F      C O M P A R E       P R O C E D U R E S      *)
  115. (*----------------------------------------------------------------------*)
  116.  
  117.  
  118. (*----------------------------------------------------------------------*)
  119. (* Which compare procedure do we use                                    *)
  120. (*----------------------------------------------------------------------*)
  121. PROCEDURE GetCompareProc (     dt : SortKeyType;
  122.                            VAR cp : CompareProc  ) : BOOLEAN;
  123.   VAR f : BOOLEAN;
  124.   BEGIN
  125.     f := TRUE;
  126.     CASE dt OF
  127.       cardinal : cp := CardinalCompare;
  128.          ObjectSize := TSIZE(CARDINAL);    |
  129.       integer  : cp := IntegerCompare;
  130.          ObjectSize := TSIZE(INTEGER);     |
  131.       real     : cp := RealCompare;
  132.          ObjectSize := TSIZE(REAL);        |
  133.       longcard : cp := LongCardCompare;
  134.          ObjectSize := TSIZE(LONGCARD);    |
  135.       longint  : cp := LongIntCompare;
  136.          ObjectSize := TSIZE(LONGINT);     |
  137.     ELSE
  138.       f := FALSE;
  139.     END; (* case *)
  140.     RETURN f;
  141.   END GetCompareProc;
  142.  
  143.  
  144. (*----------------------------------------------------------------------*)
  145. (*   S T A R T    O F    S O R T    P R O C E D U R E S                 *)
  146. (*                                                                      *)
  147. (*----------------------------------------------------------------------*)
  148.  
  149.  
  150. (*----------------------------------------------------------------------*)
  151. (* Use Selection sort for small partitions - it is faster than quicksort*)
  152. (*----------------------------------------------------------------------*)
  153. PROCEDURE SelectionSort ( StartRecPtr, EndRecPtr : ADDRESS );
  154.   VAR  MaxRecPtr, SURecPtr, SDRecPtr : ADDRESS;
  155.   li : LONGINT;
  156.   BEGIN
  157.     li := LONGINT(EndRecPtr) - LONGINT(StartRecPtr);
  158.     IF li <  LONGINT(ObjectSize) THEN
  159.        RETURN (* nowt to do *)
  160.     END;
  161.  
  162.     SDRecPtr := EndRecPtr;
  163.     WHILE ( LONGCARD(SDRecPtr) > LONGCARD(StartRecPtr) ) DO
  164.                                                 (* for each record *)
  165.       SURecPtr := StartRecPtr;
  166.       MaxRecPtr := SDRecPtr;
  167.       WHILE ( LONGCARD(SURecPtr) < LONGCARD(SDRecPtr) ) DO
  168.         IF InOrder(MaxRecPtr,SURecPtr) THEN (* SUrec is Current Max rec *)
  169.           MaxRecPtr := SURecPtr;
  170.         END; (* if *)
  171.         INC(SURecPtr,ObjectSize);
  172.       END; (* while *)
  173.       Swap(SDRecPtr,MaxRecPtr,SHORT(ObjectSize));
  174.       DEC(SDRecPtr,ObjectSize);
  175.     END; (* while *)
  176.   END SelectionSort;
  177.  
  178.  
  179. (*----------------------------------------------------------------------*)
  180. (* Given a partition then check the first, last and middle element.     *)
  181. (* move the median value to the start of the partition. This gives a    *)
  182. (* better estimate for the 'pivot' value.                               *)
  183. (*----------------------------------------------------------------------*)
  184. PROCEDURE SetMedianToStart ( pstart, pend : ADDRESS );
  185.   VAR psaddr, peaddr, pmaddr : ADDRESS;
  186.       middle : LONGCARD;
  187.   BEGIN
  188.     psaddr := pstart;
  189.     peaddr := pend;
  190.     middle := (LONGCARD(pend) - LONGCARD(pstart)) DIV LONGCARD(ObjectSize);
  191.     middle := middle DIV 2;
  192.     pmaddr :=  ADDRESS(LONGCARD(pstart) + (middle * ObjectSize));
  193.     IF  InOrder(psaddr,pmaddr) THEN          (* start  < middle *)
  194.        IF InOrder(pmaddr,peaddr) THEN        (* middle < end    *)
  195.            Swap(pmaddr,psaddr,SHORT(ObjectSize));  (* start  < mid < end *)
  196.        ELSIF InOrder(psaddr,peaddr) THEN
  197.            Swap(peaddr,psaddr,SHORT(ObjectSize)); (* start < end < mid *)
  198.        END; (* if *)
  199.     ELSE  (* middle < start *)
  200.        IF InOrder(peaddr,pmaddr) THEN         (*  end < middle   *)
  201.            Swap(pmaddr,psaddr,SHORT(ObjectSize));   (* end  < mid < str *)
  202.        ELSIF InOrder(peaddr,psaddr) THEN      (* end    < start  *)
  203.              Swap(peaddr,psaddr,SHORT(ObjectSize)); (* end  < mid < str *)
  204.        END; (* if *)
  205.     END; (* if *)
  206.   END SetMedianToStart;
  207.  
  208.  
  209. (*----------------------------------------------------------------------*)
  210. (*  Sort a Partition, This will move the elements about the pivot.      *)
  211. (*----------------------------------------------------------------------*)
  212. PROCEDURE SortPartition ( pstart, pend : ADDRESS ) : ADDRESS;
  213.   VAR  PivotPtr,
  214.        SURecPtr, SDRecPtr : ADDRESS;
  215.   BEGIN
  216.     SetMedianToStart(pstart,pend);
  217.     SURecPtr := pstart;
  218.     INC(SURecPtr,ObjectSize);
  219.     SDRecPtr := pend;
  220.     PivotPtr := pstart;
  221.  
  222.     WHILE ( LONGCARD(SURecPtr) <= LONGCARD(SDRecPtr) ) DO
  223.  
  224.       WHILE ( LONGCARD(SDRecPtr) > LONGCARD(PivotPtr) ) (* scan down for < pivot *)
  225.        AND NOT InOrder(SDRecPtr,PivotPtr) DO
  226.          DEC(SDRecPtr,ObjectSize);
  227.       END; (* while *)
  228.  
  229.       IF ( LONGCARD(SDRecPtr) > LONGCARD(PivotPtr) ) THEN
  230.          Swap(SDRecPtr,PivotPtr,SHORT(ObjectSize));
  231.          PivotPtr := SDRecPtr;
  232.          DEC(SDRecPtr,ObjectSize);
  233.       END;
  234.  
  235.       WHILE ( LONGCARD(SURecPtr) < LONGCARD(PivotPtr) )
  236.        AND InOrder(SURecPtr,PivotPtr) DO (* scanup for >= pivot *)
  237.          INC(SURecPtr,ObjectSize); (* next element to check for > than *)
  238.       END; (* while *)
  239.  
  240.  
  241.       IF ( LONGCARD(SURecPtr) < LONGCARD(PivotPtr) ) THEN
  242.          Swap(SURecPtr,PivotPtr,SHORT(ObjectSize));
  243.          PivotPtr := SURecPtr;
  244.          INC(SURecPtr,ObjectSize);
  245.       END;
  246.  
  247.     END; (* while *)
  248.  
  249.     RETURN PivotPtr;
  250.   END SortPartition;
  251.  
  252.  
  253. (*----------------------------------------------------------------------*)
  254. (*  Sort an array, this is recursive                                    *)
  255. (*----------------------------------------------------------------------*)
  256. PROCEDURE Sort ( pstart, pend : ADDRESS );
  257.   VAR   PivotPtr : ADDRESS;
  258.         lowerpartsize, upperpartsize : LONGINT;
  259.         LowerEndPtr, UpperStartPtr : ADDRESS;
  260.   BEGIN
  261.     IF ( LONGCARD(pend) - LONGCARD(pstart) ) < PartitionSizeLimit THEN
  262.        SelectionSort( pstart, pend );
  263.        RETURN;
  264.     END; (* if *)
  265.  
  266.     PivotPtr := SortPartition(pstart,pend);
  267.     lowerpartsize := LONGINT(PivotPtr) - LONGINT(pstart);
  268.     upperpartsize := LONGINT(pend) -  LONGINT(PivotPtr);
  269.  
  270.     LowerEndPtr := PivotPtr;
  271.     DEC(LowerEndPtr,ObjectSize);
  272.     UpperStartPtr := PivotPtr;
  273.     INC(UpperStartPtr,ObjectSize);
  274.  
  275.     IF lowerpartsize < upperpartsize THEN (* sort smaller first *)
  276.        IF LONGCARD(pstart) < LONGCARD(LowerEndPtr) THEN
  277.           Sort( pstart, LowerEndPtr);
  278.        END;
  279.        IF LONGCARD(UpperStartPtr) < LONGCARD(pend) THEN
  280.          Sort( UpperStartPtr,pend);
  281.        END;
  282.     ELSE
  283.        IF LONGCARD(UpperStartPtr) < LONGCARD(pend) THEN
  284.          Sort( UpperStartPtr,pend);
  285.        END;
  286.        IF LONGCARD(pstart) < LONGCARD(LowerEndPtr) THEN
  287.           Sort( pstart, LowerEndPtr);
  288.        END;
  289.     END;
  290.   END Sort;
  291.  
  292.  
  293. PROCEDURE SortArray
  294.             ( VAR ObjectArray         : ARRAY OF BYTE;
  295.                   NumberOfElements    : LONGCARD;
  296.                   TypeOfDataInKey     : SortKeyType );
  297.   VAR arrayend : ADDRESS;
  298.       arraysize:LONGCARD;
  299.   BEGIN
  300.     ObjectArrayAddr := ADR(ObjectArray);
  301.     PartitionSizeLimit := CSelSortPartitionSize * ObjectSize;
  302.     IF NOT GetCompareProc(TypeOfDataInKey,InOrder)  THEN HALT END;
  303.     arraysize := NumberOfElements * ObjectSize ;
  304.     arrayend := ADDRESS(arraysize + LONGCARD(ObjectArrayAddr));
  305.     DEC(arrayend,ObjectSize);
  306.     Sort(ObjectArrayAddr,arrayend);
  307.   END SortArray;
  308.  
  309.  
  310. PROCEDURE SortArrayWithKeys
  311.             ( VAR ObjectArray         : ARRAY OF BYTE;
  312.               VAR ExampleObject       : ARRAY OF BYTE;
  313.                   NumberOfElements    : LONGCARD;
  314.                   UserCompare         : CompareProc );
  315.   VAR arrayend : ADDRESS;
  316.       arraysize: LONGCARD;
  317.   BEGIN
  318.     ObjectArrayAddr := ADR(ObjectArray);
  319.     ObjectSize         := HIGH(ExampleObject) + 1;
  320.     PartitionSizeLimit := CSelSortPartitionSize * ObjectSize;
  321.     InOrder         := UserCompare;
  322.     arraysize       := NumberOfElements * ObjectSize;
  323.     arrayend        := ADDRESS(LONGCARD(ObjectArrayAddr) + arraysize);
  324.     DEC(arrayend,ObjectSize);
  325.     Sort(ObjectArrayAddr,arrayend);
  326.   END SortArrayWithKeys;
  327.  
  328. END QSort.
  329.  
  330.